home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / bin / make_class < prev    next >
Encoding:
Text File  |  2005-10-16  |  23.7 KB  |  785 lines
  1. #! /usr/bin/scsh \
  2. -e main -s
  3. !#
  4.  
  5. ;; Reads a C source file on stdin. Comments of the form
  6. ;;
  7. ;; /*
  8. ;; CLASS:
  9. ;;    expression
  10. ;; */
  11. ;;
  12. ;; are treated specially, and C code for the class is written to
  13. ;; stdout. Typically, the code is saved to a file and included by the
  14. ;; C source file in question.
  15.  
  16. ;; FIXME: Perhaps the files should somehow be fed through the
  17. ;; preprocessor first?
  18.  
  19. ;; FIXME: Turn this into a scheme48 module
  20.  
  21. (define-syntax let-and
  22.   (syntax-rules ()
  23.         ((let-and (expr) clause clauses ...)
  24.          (and expr (let-and clause clauses ...)))
  25.         ((let-and (name expr) clause clauses ...)
  26.          (let ((name expr))
  27.            (and name (let-and clause clauses ...))))
  28.         ((let-and expr) expr)))
  29.  
  30. (define (atom? o) (not (list? o)))
  31. (define (lambda? o) (and (pair? o) (eq? 'lambda (car o))))
  32.  
  33. (define (make-lambda formal body) `(lambda ,formal ,body))
  34. (define lambda-formal cadr)
  35. (define lambda-body caddr)
  36.  
  37. (define make-appliction list)
  38. (define application-op car)
  39. (define application-arg cadr)
  40. (define application-args cdr)
  41.  
  42. (define (normalize-application op args)
  43.   (if (null? args) op
  44.       (normalize-application (make-appliction op (car args)) (cdr args))))
  45.  
  46. ;; Transform (a b c)-> ((a b) c) and
  47. ;; (lambda (a b) ...) -> (lambda a (lambda b ...)
  48. (define (make-preprocess specials)
  49.  
  50.   (define (preprocess expr)
  51.     (if (atom? expr) expr
  52.     (let ((op (car expr)))
  53.       (cond ((and (atom? op)
  54.               (assq op specials))
  55.          => (lambda (pair) ((cdr pair) (cdr expr) preprocess)))
  56.         (else
  57.          (normalize-application (preprocess op)
  58.                     (map preprocess (cdr expr))))))))
  59.   preprocess)
  60.  
  61. (define preprocess-applications (make-preprocess '()))
  62.  
  63. (define (do-lambda args preprocess)
  64.   (let loop ((formals (reverse (car args)))
  65.          (body (preprocess (cadr args))))
  66.     (if (null? formals) body
  67.     (loop (cdr formals)
  68.           (make-lambda (car formals) body)))))
  69.  
  70. (define (do-let* args preprocess)
  71.   (let loop ((definitions (reverse (car args)))
  72.          (body (preprocess (cadr args))))
  73.     (if (null? definitions) body
  74.     (loop (cdr definitions)
  75.           (make-appliction
  76.            (make-lambda (caar definitions)
  77.                 body)
  78.            (preprocess (cadar definitions)))))))
  79.  
  80. (define (do-let args preprocess)
  81.   (let ((definitions (car args))
  82.     (body (cadr args)))
  83.     (normalize-application 
  84.      (do-lambda (list (map car definitions) body) preprocess)
  85.      (map cadr definitions))))
  86.  
  87. (define preprocess (make-preprocess
  88.             `((lambda . ,do-lambda)
  89.               (let . ,do-let)
  90.               (let* . ,do-let*))))
  91.   
  92. (define (free-variable? v expr)
  93.   (cond ((atom? expr) (eq? v expr))
  94.     ((lambda? expr)
  95.      (and (not (eq? v (lambda-formal expr)))
  96.           (free-variable? v (lambda-body expr))))
  97.     (else
  98.      (or (free-variable? v (application-op expr))
  99.          (free-variable? v (application-arg expr))))))
  100.  
  101. (define (match pattern expr)
  102.   (if (atom? pattern)
  103.       (if (eq? '* pattern) (list expr)
  104.       (and (eq? pattern expr) '()))
  105.       (let-and ((pair? expr))
  106.            (op-matches (match (application-op pattern)
  107.                   (application-op expr)))
  108.            (arg-matches (match (application-arg pattern)
  109.                    (application-arg expr)))
  110.            (append op-matches arg-matches))))
  111.  
  112. (define (rule pattern f)
  113.   (cons (preprocess-applications pattern) f))
  114.  
  115. (define (make-K e) (make-combine 'K e))
  116. (define (make-S p q) (make-combine 'S p q))
  117. ;; (define (make-B p) (make-combine 'B p))
  118. ;; (define (make-C p q) (make-combine 'C p q))
  119. ;; (define (make-S* p q) (make-combine 'S* p q))
  120. ;; (define (make-B* p q) (make-combine 'B* p q))
  121. ;; (define (make-C* p q) (make-combine 'C* p q))
  122.  
  123. ;; Some mor patterns that can ba useful for optimization. From "A
  124. ;; combinator-based compiler for a functional language" by Hudak &
  125. ;; Kranz.
  126.  
  127. ;; S K => K I
  128. ;; S (K I) => I
  129. ;; S (K (K x)) => K (K x)
  130. ;; S (K x) I => x
  131. ;; S (K x) (K y) => K (x y)
  132. ;; S f g x = f x (g x)
  133. ;; K x y => x
  134. ;; I x => x
  135. ;; Y (K x) => x
  136.  
  137. (define optimizations
  138.   (list (rule '(S (K *) (K *)) (lambda (p q) (make-K (make-appliction p q))))
  139.     (rule '(S (K *) I) (lambda (p) p))
  140.     ;; (rule '(B K I) (lambda () 'K))
  141.     (rule '(S (K *) (B * *)) (lambda (p q r) (make-combine 'B* p q r)))
  142.     (rule '(S (K *) *) (lambda (p q) (make-combine 'B p q)))
  143.     (rule '(S (B * *) (K *))  (lambda (p q r) (make-combine 'C* p q r)))
  144.     ;; (rule '(C (B * *) *) (lambda (p q r) (make-combine 'C* p q r)))
  145.     (rule '(S * (K *)) (lambda (p q) (make-combine 'C p q)))
  146.     (rule '(S (B * * ) r) (lambda (p q r) (make-combine 'S* p q r)))))
  147.  
  148. (define (optimize expr)
  149.   ;; (werror "optimize ~S\n" expr)
  150.   (let loop ((rules optimizations))
  151.     ;; (if (not (null? rules)) (werror "trying pattern ~S\n" (caar rules)) )
  152.     (cond ((null? rules) expr)
  153.       ((match (caar rules) expr)
  154.        => (lambda (parts) (apply (cdar rules) parts)))
  155.       (else (loop (cdr rules))))))
  156.  
  157. (define (optimize-application op args)
  158.   (if (null? args) op
  159.       (optimize-application (optimize (make-appliction op (car args)))
  160.                 (cdr args))))
  161.  
  162. (define (make-combine op . args)
  163.   (optimize-application op args))
  164.  
  165. (define (translate-expression expr)
  166.   (cond ((atom? expr) expr)
  167.     ((lambda? expr)
  168.      (translate-lambda (lambda-formal expr)
  169.                (translate-expression (lambda-body expr))))
  170.     (else
  171.      (make-appliction (translate-expression (application-op expr))
  172.               (translate-expression (application-arg expr))))))
  173.  
  174. (define (translate-lambda v expr)
  175.   (cond ((atom? expr)
  176.      (if (eq? v expr) 'I (make-K expr)))
  177.     ((lambda? expr)
  178.      (error "translate-lambda: Unexpected lambda" expr))
  179.     (else
  180.      (make-S (translate-lambda v (application-op expr))
  181.                (translate-lambda v (application-arg expr))))))
  182.   
  183. (define (make-flat-application op arg)
  184.   (if (atom? op) `(,op ,arg)
  185.       `(,@op ,arg)))
  186.       
  187. (define (flatten-application expr)
  188.   (if (or (atom? expr) (lambda? expr)) expr
  189.       (make-flat-application (flatten-application (application-op expr))
  190.                  (flatten-application (application-arg expr)))))
  191.  
  192. (define (translate expr)
  193.   (flatten-application (translate-expression (preprocess expr))))
  194.  
  195. ;;; Test cases
  196. ;; (translate '(lambda (port connection)
  197. ;;                 (start-io (listen port connection)
  198. ;;                 (open-direct-tcpip connection))))
  199. ;;  ===> (C (B* S (B start-io) listen) open-direct-tcpip)
  200. ;; 
  201. ;; (translate '(lambda (f) ((lambda (x) (f (lambda (z) ((x x) z))))
  202. ;;                 (lambda (x) (f (lambda (z) ((x x) z)))) )))
  203. ;; ===> (S (C B (S I I)) (C B (S I I)))
  204. ;; 
  205. ;; (translate '(lambda (r) (lambda (x) (if (= x 0) 1 (* x (r (- x 1)))))))
  206. ;; ===> (B* (S (C* if (C = 0) 1)) (S *) (C B (C - 1)))
  207.  
  208.  
  209. (define (werror f . args)
  210.   (display (apply format #f f args) 2))
  211.  
  212. (define (string-prefix? prefix s)
  213.   (let ((l (string-length prefix)))
  214.     (and (<= l (string-length s))
  215.      (string=? prefix (substring s 0 l)))))
  216.     
  217. (define (read-expression p)
  218.   (let ((line (read-line)))
  219.     ; (werror "read line: '~s'\n" (if (eof-object? line) "<EOF>" line))
  220.     (cond ((eof-object? line) line)
  221.       ((p line) (read))
  222.       (else (read-expression p)))))
  223.  
  224. (define (get key alist select)
  225.   (cond ((assq key alist) => select)
  226.     (else #f)))
  227.  
  228. (define (append-deep o)
  229.   ; (werror "append-deep: ~S\n" o)
  230.   (cond ((string? o) o)
  231.     ((symbol? o) (symbol->string o))
  232.     ((number? o) (number->string o))
  233.     (else
  234.      (apply string-append (map append-deep o)))))
  235.  
  236. (define (identity x) x)
  237.  
  238. (define (filter p list)
  239.   (cond ((null? list) list)
  240.     ((p (car list)) (cons (car list)
  241.                   (filter p (cdr list))))
  242.     (else (filter p (cdr list)))))
  243.  
  244. (define (implode list separator)
  245.   (cond ((null? list) '())
  246.     ((null? (cdr list)) list)
  247.     (else `(,(car list) ,separator ,@(implode (cdr list) separator)))))
  248.  
  249. (define (atom? x) (or (symbol? x) (string? x)))
  250.  
  251. ;; Variables are describes as lists (name . type)
  252. ;; Known types (and corresponding C declarations) are
  253. ;;
  254. ;; (string)          struct ol_string *name
  255. ;; (object class)    struct class *name
  256. ;; (bignum)          mpz_t name
  257. ;; (simple c-type)   c-type
  258. ;; (special c-type mark-fn free-fn)
  259. ;; (special-struct c-type mark-fn free-fn)
  260. ;;
  261. ;; (struct tag)
  262. ;;
  263. ;; (array type size) type name[size]
  264. ;; Variable size array (must be last) */
  265. ;; (var-array type size-field)  type name[1]
  266. ;;
  267. ;; (pointer type)    type *name
  268. ;; (space type)      Like pointer, but should be freed
  269. ;;
  270. ;; (function type . arg-types) type name(arg-types)
  271. ;;
  272. ;; NOTE: For function types, the arguments are represented simply as
  273. ;; strings or lists containing C declarations; they do not use the
  274. ;; type syntax.
  275. ;;
  276. ;; (method type args)
  277. ;; is transformed into (pointer (function type self-arg args)) before
  278. ;; processing,
  279.  
  280. (define (type->category type)
  281.   (if (atom? type)
  282.       (type->category `(simple ,type))
  283.       (let ((tag (car type)))
  284.     (case tag
  285.       ((string object static-object simple special special-struct
  286.         indirect-special space bignum struct) tag)
  287.       ((array var-array pointer) (type->category (cadr type)))
  288.       
  289.       (else (error "make_class: type->category: Invalid type" type))))))
  290.  
  291. (define (type->declaration type expr)
  292.   (if (atom? type)
  293.       (type->declaration `(simple ,type) expr)
  294.       (case (car type)
  295.     ((string) (list "struct ol_string *" expr))
  296.     ((object) (list "struct " (cadr type) " *" expr))
  297.     ((static-object) (list "struct " (cadr type) " " expr))
  298.     ((struct) (list "struct " (cadr type) " " expr)) 
  299.     ((bignum) (list "mpz_t " expr))
  300.     ((simple special special-struct indirect-special) (list (cadr type) " " expr))
  301.     ((pointer space) (type->declaration (cadr type)
  302.                         (list "(*(" expr "))")))
  303.     ((array)  (type->declaration (cadr type)
  304.                      (list "((" expr ")[" (caddr type) "])")))
  305.     ((var-array)  (type->declaration (cadr type)
  306.                      (list "((" expr ")[1])")))
  307.     ((function) (type->declaration (cadr type)
  308.                        (list expr
  309.                          "(" (implode (cddr type) ", ")
  310.                          ")")))
  311.     (else (error "make_class: type->declaration: Invalid type" type)))))
  312.  
  313. (define (type->mark type expr)
  314.   (if (atom? type)
  315.       (type->mark `(simple ,type) expr)
  316.       (case (car type)
  317.     ((string simple function space bignum) #f)
  318.     ((object) (list "mark((struct ol_object *) " expr ");\n"))
  319.     ((static-object) (list "mark((struct ol_object *) &" expr ");\n"))
  320.     ((struct) (list (cadr type) "_mark(&" expr ", mark);\n"))
  321.     ((pointer) (if (null? (cddr type))
  322.                (type->mark (cadr type) (list "*(" expr ")"))
  323.  
  324.                ;; The optional argument should be the name of
  325.                ;; an instance variable holding the length of
  326.                ;; the area pointed to
  327.                (let ((mark-k (type->mark (cadr type)
  328.                          (list "(" expr ")[k]"))))
  329.              (and mark-k
  330.                   (list "{\n  unsigned k;\n"
  331.                     "  for (k=0; k<i->" (caddr type)
  332.                     "; k++)\n"
  333.                     "    " mark-k
  334.                     "}\n")))))
  335.  
  336.     ((special) (let ((mark-fn (caddr type)))
  337.              (and mark-fn (list mark-fn "(" expr ", mark);\n"))))
  338.         ((indirect-special) (let ((mark-fn (caddr type)))
  339.                               (and mark-fn (list mark-fn "(&(" expr
  340.                                                  "), mark);\n"))))
  341.     ((special-struct) (let ((mark-fn (caddr type)))
  342.                 (and mark-fn (list mark-fn "(&(" expr "), mark);\n"))))
  343.     
  344.     ;; FIXME: Doesn't handle nested arrays
  345.     ((array)
  346.      (let ((mark-k (type->mark (cadr type) (list "(" expr ")[k]"))))
  347.        (and mark-k
  348.         (list "{\n  unsigned k;\n"
  349.               "  for (k=0; k<" (caddr type) "; k++)\n"
  350.               "    " mark-k
  351.               "}\n"))))
  352.     ((var-array)
  353.      (let ((mark-k (type->mark (cadr type) (list "(" expr ")[k]"))))
  354.        (and mark-k
  355.         (list "{\n  unsigned k;\n"
  356.               "  for (k=0; k<i->" (caddr type) "; k++)\n"
  357.               "    " mark-k
  358.               "}\n"))))
  359.      
  360.     (else (error "make_class: type->mark: Invalid type" type)))))
  361.  
  362. (define (type->free type expr)
  363.   (define (free/f f)
  364.     (and f (list f "(" expr ");\n")))
  365.  
  366.   (if (atom? type)
  367.       (type->free `(simple ,type) expr)
  368.       (case (car type)
  369.     ((object simple function pointer) #f)
  370.     ((static-object) (list "CLASS(" (cadr type) ").free_instance((struct ol_object *) &" expr ");\n"))
  371.     ((struct) (list (cadr type) "_free(&" expr ");\n"))
  372.     ((string) (free/f "ol_string_free"))
  373.     ((bignum) (free/f "mpz_clear"))
  374.     ((space) (free/f "ol_space_free"))
  375.     ((special) (free/f (cadddr type)))
  376.     ((special-struct) (let ((free-fn (cadddr type)))
  377.                 (and free-fn
  378.                  (list free-fn "(&(" expr "));\n")))) 
  379.         ((indirect-special) (let ((free-fn (cadddr type)))
  380.                               (and free-fn
  381.                                    (list free-fn "(&(" expr "));\n"))))
  382.  
  383.     
  384.     ((array)
  385.      (let ((free-k (type->free (cadr type) (list "(" expr ")[k]"))))
  386.        (and free-k
  387.         (list "{\n  unsigned k;\n"
  388.               "  for (k=0; k<" (caddr type) "; k++)\n"
  389.               "    " free-k
  390.               "}\n"))))
  391.     ((var-array)
  392.      (let ((free-k (type->free (cadr type) (list "(" expr ")[k]"))))
  393.        (and free-k
  394.         (list "{\n  unsigned k;\n"
  395.               "  for (k=0; k<i->" (caddr type) "; k++)\n"
  396.               "    " free-k
  397.               "}\n"))))
  398.     
  399.     (else (error "make_class: type->free: Invalid type" type)))))
  400.  
  401. #!
  402. (define (type->init type expr)
  403.   (if (atom? type)
  404.       (type->init `(simple ,type) expr)
  405.       (case (car type)
  406.     ((object string space pointer) (list expr "= NULL;\n"))
  407.     ((bignum) (list "mpz_init(" expr ");\n"))
  408.     ((array)
  409.      (let ((init-k (type->init (cadr type) (list "(" expr ")[k]"))))
  410.        (and init-k
  411.         (list "{\n  unsigned k;\n"
  412.               "  for (k=0; k<" (caddr type) "; k++)\n"
  413.               "    " init-k
  414.               "}\n"))))
  415.  
  416.     (else (error "make_class: type->init: Invalid type" type)))))
  417. !#
  418.  
  419. (define var-name car)
  420. (define var-type cdr)
  421.  
  422. (define (fix-method name var)
  423.   (let ((type (var-type var))
  424.     (variable (var-name var)))
  425.     (if (atom? type)
  426.     var
  427.     (case (car type)
  428.       ((method)
  429.        `(,variable pointer (function ,(cadr type)
  430.                      ("struct " ,name " *self")
  431.                      ,@(cddr type))))
  432.       ((indirect-method)
  433.        `(,variable pointer (function ,(cadr type)
  434.                      ("struct " ,name " **self")
  435.                      ,@(cddr type))))
  436.       (else var)))))
  437.  
  438. (define (do-instance-struct name super vars)
  439.   ; (werror "do-instance-struct\n")
  440.   (list "struct " name 
  441.     "\n{\n"
  442.     "  struct " (or super "ol_object") " super;\n"
  443.     (map (lambda (var)
  444.            (list "  " (type->declaration (var-type var)
  445.                          (var-name var)) ";\n"))
  446.          vars)
  447.     "};\n"))
  448.  
  449. (define (do-struct name super vars)
  450.   ; (werror "do-struct\n")
  451.   (list "struct " name 
  452.     "\n{\n"
  453.     (map (lambda (var)
  454.            (list "  " (type->declaration (var-type var)
  455.                          (var-name var)) ";\n"))
  456.          vars)
  457.     "};\n"))
  458.  
  459. (define (do-mark-function name vars)
  460.   ; (werror "do-mark-function\n")
  461.   (let ((markers (filter identity
  462.              (map (lambda (var)
  463.                 (type->mark (var-type var)
  464.                         (list "i->" (var-name var))))
  465.                   vars))))
  466.     ; (werror "gazonk\n")
  467.     (and (not (null? markers))
  468.      (list "static void do_"
  469.            name "_mark(struct ol_object *o, \n"
  470.            "void (*mark)(struct ol_object *o))\n"
  471.            "{\n"
  472.            "  struct " name " *i = (struct " name " *) o;\n"
  473.            (map (lambda (x) (list "  " x))
  474.             markers)
  475.            "}\n\n"))))
  476.  
  477. (define (do-free-function name vars)
  478.   ; (werror "do-free-function\n")
  479.   (let ((freers (filter identity
  480.             (map (lambda (var)
  481.                    (type->free (var-type var) 
  482.                        (list "i->" (var-name var))))
  483.                  
  484.                  vars))))
  485.     ; (werror "gazonk\n")
  486.  
  487.     (and (not (null? freers))
  488.      (list "static void do_"
  489.            name "_free(struct ol_object *o)\n"
  490.            "{\n"
  491.            "  struct " name " *i = (struct " name " *) o;\n"
  492.            (map (lambda (x) (list "  " x))
  493.             freers)
  494.            "}\n\n"))))
  495.  
  496. (define (declare-struct-mark-function name)
  497.   (list "void "    name "_mark(struct " name " *i, \n"
  498.     "    void (*mark)(struct ol_object *o))"))
  499.  
  500. (define (do-struct-mark-function name vars)
  501.   ; (werror "do-struct-mark-function\n")
  502.   (let ((markers (filter identity
  503.              (map (lambda (var)
  504.                 (type->mark (var-type var)
  505.                         (list "i->" (var-name var))))
  506.                   vars))))
  507.     ; (werror "gazonk\n")
  508.     (list (declare-struct-mark-function name)
  509.       "\n{\n"
  510.       ; To avoid warnings for unused parameters
  511.       "  (void) mark; (void) i;\n"
  512.       (map (lambda (x) (list "  " x))
  513.            markers)
  514.       "}\n\n")))
  515.  
  516. (define (declare-struct-free-function name)
  517.   (list "void " name "_free(struct " name " *i)"))
  518.  
  519. (define (do-struct-free-function name vars)
  520.   ; (werror "do-struct-free-function\n")
  521.   (let ((freers (filter identity
  522.             (map (lambda (var)
  523.                    (type->free (var-type var) 
  524.                        (list "i->" (var-name var))))
  525.                  
  526.                  vars))))
  527.     ; (werror "gazonk\n")
  528.  
  529.     (list (declare-struct-free-function name)
  530.       "\n{\n"
  531.       ; To avoid warnings for unused parameters
  532.       "  (void) i;\n"
  533.       (map (lambda (x) (list "  " x))
  534.            freers)
  535.       "}\n\n")))
  536.  
  537. (define (do-class name super mark-function free-function meta methods)
  538.   (define initializer
  539.     (list "{ STATIC_HEADER,\n  "
  540.       (if super
  541.           ; FIXME: A cast (struct ol_class *) or something
  542.           ; equivalent is needed if the super class is not a
  543.           ; struct ol_class *. For now, fixed with macros
  544.           ; expanding to the right component of extended class
  545.           ; structures.
  546.           (list "&" super "_class")
  547.           "0")
  548.       ", \"" name "\", sizeof(struct " name "),\n  "
  549.       (if mark-function (list "do_" name "_mark") "NULL") ",\n  "
  550.       (if free-function (list "do_" name "_free") "NULL") "\n"
  551.       "}"))
  552.   ; (werror "do-class\n")
  553.   (if meta
  554.       (list "struct " meta "_meta " name "_class_extended =\n"
  555.         "{ " initializer 
  556.         (if methods
  557.         (map (lambda (m) (list ",\n  " m)) methods)
  558.         "")
  559.         "};\n"
  560.         "#define " name "_class (" name "_class_extended.super)\n")
  561.       (list "struct ol_class " name "_class =\n"
  562.         initializer ";\n")))
  563.  
  564. (define (process-class attributes)
  565.   (let ((name (get 'name attributes cadr))
  566.     (super (get 'super attributes cadr))
  567.     (raw-vars (get 'vars attributes cdr))
  568.     (meta (get 'meta attributes cadr))
  569.     (methods (get 'methods attributes cdr)))
  570.     (werror "Processing class ~S\n" name)
  571.     ; (werror "foo\n")
  572.     (let ((vars (map (lambda (var) (fix-method name var))
  573.              raw-vars)))
  574.       (let ((mark-function (do-mark-function name vars))
  575.         (free-function (do-free-function name vars)))
  576.     ; (werror "baar\n")
  577.     (list "#ifndef CLASS_DEFINE\n"    
  578.           (do-instance-struct name super vars)
  579.           (if meta
  580.           (list "extern struct " meta "_meta "
  581.             name "_class_extended;\n")
  582.           (list "extern struct ol_class " name "_class;\n"))
  583.           "#endif /* !CLASS_DEFINE */\n\n"
  584.           "#ifndef CLASS_DECLARE\n"
  585.           (or mark-function "")
  586.           (or free-function "")
  587.           (do-class name super mark-function free-function
  588.             meta methods)
  589.           "#endif /* !CLASS_DECLARE */\n\n")))))
  590.  
  591. (define (process-meta attributes)
  592.   (let ((name (get 'name attributes cadr))
  593.     (methods (get 'methods attributes cdr)))
  594.     (werror "Processing meta ~S\n" name)
  595.     (list "#ifndef CLASS_DEFINE\n"
  596.       "struct " name "_meta\n"
  597.       "{\n"
  598.       "  struct ol_class super;\n"
  599.       (map (lambda (m) (list "  " m ";\n"))
  600.            methods)
  601.       "};\n"
  602.       "#endif /* !CLASS_DEFINE */\n\n")))
  603.  
  604. (define (process-struct attributes)
  605.   (let ((name (get 'name attributes cadr))
  606.     (super (get 'super attributes cadr))
  607.     (raw-vars (get 'vars attributes cdr))
  608.     (meta (get 'meta attributes cadr))
  609.     (methods (get 'methods attributes cdr)))
  610.     (werror "Processing struct ~S\n" name)
  611.     ; (werror "foo\n")
  612.     ;; FIXME: Is this really needed?
  613.     (let ((vars (map (lambda (var) (fix-method name var))
  614.              raw-vars)))
  615.       ; (werror "baar\n")
  616.       (list "#ifndef CLASS_DEFINE\n"    
  617.         (do-struct name super vars)
  618.         "extern " (declare-struct-mark-function name) ";\n"
  619.         "extern " (declare-struct-free-function name) ";\n"
  620.         "#endif /* !CLASS_DEFINE */\n\n"
  621.         "#ifndef CLASS_DECLARE\n"
  622.         (do-struct-mark-function name vars)
  623.         (do-struct-free-function name vars)
  624.         "#endif /* !CLASS_DECLARE */\n\n"))))
  625.  
  626. ;;;; Expression compiler
  627.  
  628. ;; Can't use load; it writes messages to stdout.
  629. ;;(load 'compiler)
  630.  
  631. ;; Constants is an alist of (name value call_1 call_2 ... call_n)
  632. ;; where value is a C expression representing the value. call_i is
  633. ;; present, it is a function that can be called to apply the value to
  634. ;; i arguments directly.
  635. (define (make-output constants)
  636.   ;; OP and ARGS are C expressons
  637.   (define (apply-generic op args)
  638.     ;; (werror "(apply-generic ~S)\n" (cons op args))
  639.     (if (null? args) op
  640.     (apply-generic (list "A(" op ", " (car args) ")")
  641.                (cdr args))))
  642.   ;; INFO is the (value [n]) associated with a constant,
  643.   ;; and ARGS is a list of C expressions
  644.   (define (apply-constant info args)
  645.     ;; (werror "apply-constant : ~S\n" info)
  646.     ;; (werror "          args : ~S\n" args)
  647.     (let ((calls (cdr info)))
  648.       (if (null? calls)
  649.     (apply-generic (car info) args)
  650.     (let ((n (min (length calls) (length args))))
  651.       ;; (werror "n: ~S\n" n)
  652.       (apply-generic (list (nth info n)
  653.                    "(" (implode (list-prefix args n) ", ") ")")
  654.              (list-tail args n))))))
  655.   (define (lookup-global v)
  656.     (cond ((assq v constants) => cdr)
  657.       (else (error "make_class: undefined global" v))))
  658.   
  659.   (define (output-expression expr)
  660.     ;; (werror "output-expression ~S\n" expr)
  661.     (if (atom? expr)
  662.     (car (lookup-global expr))
  663.     (let ((op (application-op expr))
  664.           (args (map output-expression (application-args expr))))
  665.       (if (atom? op)
  666.           (apply-constant (lookup-global op) args)
  667.           (apply-generic op args)))))
  668.   output-expression)
  669.  
  670. (define (process-expr attributes)
  671.   (define (declare-params params)
  672.     (implode (map (lambda (var)
  673.             (type->declaration (var-type var)
  674.                        (var-name var)))
  675.           params)
  676.          ", "))
  677.   (define (params->alist params)
  678.     (map (lambda (var)
  679.        (let ((name (var-name var)))
  680.          (list name (list "((struct ol_object *) " name ")" ))))
  681.      params))
  682.   
  683.   ;; (werror "foo\n")
  684.   (let ((name (get 'name attributes cadr))
  685.     (globals (or (get 'globals attributes cdr) '()))
  686.     (params (get 'params attributes cdr))
  687.     (expr (get 'expr attributes cadr)))
  688.     (werror "Processing expression ~S\n" name)
  689.     (let ((translated (translate expr)))
  690.       (werror "Compiled to ~S\n" translated)
  691.       (list "static struct ol_object *\n" name "("
  692.         (if params (declare-params params) "void")
  693.         ")\n{\n"
  694.         (format #f "  /* ~S */\n" translated)
  695.         "#define A CLASS_APPLY\n"
  696.         "#define I CLASS_VALUE_I\n"
  697.         "#define K CLASS_VALUE_K\n"
  698.         "#define K1 CLASS_APPLY_K_1\n"
  699.         "#define S CLASS_VALUE_S\n"
  700.         "#define S1 CLASS_APPLY_S_1\n"
  701.         "#define S2 CLASS_APPLY_S_2\n"
  702.         "#define B CLASS_VALUE_B\n"
  703.         "#define B1 CLASS_APPLY_B_1\n"
  704.         "#define B2 CLASS_APPLY_B_2\n"
  705.         "#define C CLASS_VALUE_C\n"
  706.         "#define C1 CLASS_APPLY_C_1\n"
  707.         "#define C2 CLASS_APPLY_C_2\n"
  708.         "#define Sp CLASS_VALUE_Sp\n"
  709.         "#define Sp1 CLASS_APPLY_Sp_1\n"
  710.         "#define Sp2 CLASS_APPLY_Sp_2\n"
  711.         "#define Sp3 CLASS_APPLY_Sp_3\n"
  712.         "#define Bp CLASS_VALUE_Bp\n"
  713.         "#define Bp1 CLASS_APPLY_Bp_1\n"
  714.         "#define Bp2 CLASS_APPLY_Bp_2\n"
  715.         "#define Bp3 CLASS_APPLY_Bp_3\n"
  716.         "#define Cp CLASS_VALUE_Cp\n"
  717.         "#define Cp1 CLASS_APPLY_Cp_1\n"
  718.         "#define Cp2 CLASS_APPLY_Cp_2\n"
  719.         "#define Cp3 CLASS_APPLY_Cp_3\n"
  720.         "  return\n    "
  721.         ((make-output (append '( (I I)
  722.                      (K K K1)
  723.                      (S S S1 S2)
  724.                      (B B B1 B2)
  725.                      (C C C1 C2)
  726.                      (S* Sp Sp1 Sp2 Sp3)
  727.                      (B* Bp Bp1 Bp2 Bp3)
  728.                      (C* Cp Cp1 Cp2 Cp3))
  729.                   globals
  730.                   (if params
  731.                       (params->alist params)
  732.                       '())))
  733.          translated)
  734.         ";\n"
  735.         "#undef A\n"
  736.         "#undef I\n" 
  737.         "#undef K\n"
  738.         "#undef K1\n"
  739.         "#undef S\n"
  740.         "#undef S1\n"
  741.         "#undef S2\n"
  742.         "#undef B\n"
  743.         "#undef B1\n"
  744.         "#undef B2\n"
  745.         "#undef C\n"
  746.         "#undef C1\n"
  747.         "#undef C2\n"
  748.         "#undef Sp\n"
  749.         "#undef Sp1\n"
  750.         "#undef Sp2\n"
  751.         "#undef Sp3\n"
  752.         "#undef Bp\n"
  753.         "#undef Bp1\n"
  754.         "#undef Bp2\n"
  755.         "#undef Bp3\n"
  756.         "#undef Cp\n"
  757.         "#undef Cp1\n"
  758.         "#undef Cp2\n"
  759.         "#undef Cp3\n"
  760.         "}\n"))))
  761.  
  762. (define (process-input exp)
  763.   (let ((type (car exp))
  764.     (body (cdr exp)))
  765.     ;; (werror "process-class: type = ~S\n" type)
  766.     (case type
  767.       ((class) (process-class body))
  768.       ((meta) (process-meta body))
  769.       ((struct) (process-struct body))
  770.       ((expr) (process-expr body))
  771.       (else (list "#error Unknown expression type " type "\n")))))
  772.  
  773. (define main
  774.   (let ((test (lambda (s) (string-prefix? "/* CLASS:" s))))
  775.     (lambda args
  776.       (let ((exp (read-expression test)))
  777.     (if (not (eof-object? exp))
  778.         (begin
  779.           (display (append-deep (process-input exp)))
  780.           (main))
  781.             0)))))
  782.  
  783. ; (main)
  784.  
  785.